home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CU Amiga Super CD-ROM 19
/
CU Amiga Magazine's Super CD-ROM 19 (1998)(EMAP Images)(GB)[!][issue 1998-02].iso
/
CUCD
/
Utilities
/
Scion
/
ARexx
/
GEDCOM2Scion.rexx
< prev
next >
Wrap
OS/2 REXX Batch file
|
1997-11-04
|
49KB
|
1,485 lines
/****************************************************************************
* *
* *
* $VER: GEDCOM2Scion.rexx 2.32 (30 Oct 1997)
* *
* Written by Freddy Ariës *
* Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands. *
* *
* This program was created to import GEDCOM data into the Scion database. *
* It should work pretty good by now, although no guarantees whatsoever *
* are made. If you have problems using this script, please contact me, and *
* describe exactly what the problem is, or better yet, send me a copy of *
* the GEDCOM file you are trying to read), and I will try to fix it. *
* *
* GEDCOM was developed by the Family History Department of the Church of *
* Jesus Christ of Latter-day Saints to provide a flexible uniform format *
* for exchanging computerized genealogical data. GEDCOM is an acronym for *
* GEnealogical Data COMmunication. GEDCOM is provided to foster the *
* sharing of genealogical information and the development of a wide range *
* of inter-operable software products to assist genealogists, historians, *
* and other researchers. *
* *
* + SCION must be running for this AREXX script to work. *
* + This script uses (by default) the rexxreqtools.library (which requires *
* a version of reqtools larger than 2.0 and rexxsyslib.library). *
* If you do not have these, run SetDefaults.rexx to change the settings. *
* + Even though this script does no parsing of dates, it's safer if they *
* are in the exact format "DD MMM YYYY". *
* *
* DONE: - progress indicator, using rexxarplib.library (requested by *
* Robbie J. Akins himself). *
* - now also recognizes full formal tag-names... due to the way eg. *
* Family Tree Maker for Windows creates its (PAF) GEDCOM output. *
* - should now correctly parse files containing ^M (carriage return) *
* characters (usually MS-DOS ASCII files that weren't stripped). *
* - creation of external note files for multi-line GEDCOM comments *
* (option) *
* - use of SOUR structure data for the Reference fields (currently *
* not very smart) *
* - now uses preference file for default settings *
* - improved skipping of (unrecognized) structures *
* - recognition and parsing of GEDCOM dates for Scion v5 *
* *
* All unrecognized fields or fields that Scion doesn't use, are skipped. *
* NOTES: *
* + The program generates a file FILENAME.log (where FILENAME is the *
* name of the GEDCOM file read), in the directory where the GEDCOM file *
* is located. This .log file contains parsing info about which lines were *
* skipped and which non-fatal errors were encountered. It may be a good *
* idea to read this file! *
* + FAMS and FAMC fields, and EVEN structures will always be skipped, *
* because I use another method of establishing family (spouse & children) *
* relationships. If no relationships are established, this probably means *
* that the imported file does not support that other method. If you *
* encounter such a file, please send it to me, and tell me what program *
* generated it. If this happens a lot, I will add support for the parsing *
* of these relations in a future version. *
* + If you see strange strings in the Reference fields (eg. something like *
* "R1"), you may be able to find more reference information in the GEDCOM *
* file in the SOUR structure with that reference number (eg. @R1@). *
* *
* TO DO (but low priority, unless someone really wants this [?]): *
* - Import GEDCOM address data into Scion V5 personal/family addresses *
* (soon!) *
* - Add Shell options for the processing of note files *
* - More intelligent processing of SOUR structures for Reference fields *
* - Add support for other character sets (like the ANSEL format that is *
* described in the GEDCOM specification) [external conversion program?] *
* - Add support for EVEN(t) structures *
* - Maybe someday even a way to allow modifying an existing database. *
* The current version will only add to a database, and doesn't care for *
* double entries. Don't hold your breath for this one, though! *
* - Suggestions, comments, bugreports, donations, etc. are appreciated. *
* *
****************************************************************************/
options failat 20; options results
arg inname inval
versionstr = "2.32"
/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; prgrs = 1; pgopen = 0; outp = 1
scrdev = stdout
PSCR = "SCIONGEN"
notesdir = ""
scrname = "CON:0//639//Scion_Output/AUTO/WAIT/CLOSE/SCREEN"
donotes = 0; lnum = 0
NL = '0A'x
signal on IOERR
do while inname = '?'
writeln(stdout, "INFILE/A,QUIET/S,NOREQ/S ")
pull inname inval
end
/* read preferences file */
if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
do while ~eof(pfile)
inln = readln(pfile)
if inln ~= "" then do
wstr = upper(word(inln, 1))
if wstr = "NOTES" then
notesdir = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
else if wstr = "USEREQ" then
usereq = 1
else if wstr = "NOUSEREQ" then
usereq = 0
else if wstr = "PROGRESS" then
prgrs = 1
else if wstr = "NOPROGRESS" then
prgrs = 0
else if wstr = "PUBSCREEN" then
pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
end
end
close(pfile)
end
if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
pscr = "SCIONGEN"
wstr = right(notesdir, 1)
if wstr ~= '/' & wstr ~= ':' then notesdir = ""
scrname = scrname||pscr
/* parse command line options, to enable calling the script automatically,
* eg. from a function key. This gets priority over global settings!
*/
if inname ~= "" then do
if inname = "QUIET" | inname = "NOREQ" then do
inval = inname; inname = ""
end
end
if inval = "QUIET" then do
outp = 0; usereq = 0
end
else if inval = "NOREQ" then usereq = 0
if usereq & ~show('l','rexxreqtools.library') then do
if exists('libs:rexxreqtools.library') then
call addlib('rexxreqtools.library',0,-30,0)
else do
usereq = 0; outp = 1
Tell("Unable to open rexxreqtools.library - using text output")
end
end
if ~usereq then prgrs = 0
if ~show('l','rexxarplib.library') then do
if exists('libs:rexxarplib.library') then do
/* rexxarplib is present - start it */
call addlib('rexxarplib.library',0,-30,0)
screentofront(pscr)
end
else
prgrs = 0
end
else do
/* rexxarplib is already in memory */
screentofront(pscr)
end
if ~show('P','SCIONGEN') then do
EndString('I am sorry to say that the SCION Genealogist' || NL ||,
'database is not available. Please start the' || NL ||,
'SCION program BEFORE using this script!')
end
myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
GETPROGVERSION
prgvers = RESULT
if outp & ~usereq then do
if pscr ~= "WORKBENCH" then do
scrdev = 'SCNG2SSCR'
if ~open(scrdev, scrname, 'w') then scrdev = stdout
end
Tell("GEDCOM to Scion conversion script v"||versionstr||" by Freddy Ariës")
Tell("Scion (output) database: "||dbname)
end
if inname = "" then do
/* ignore the value of outp; if we can't ask for the input file,
* we can't do anything!
*/
if usereq then do
/* We need a file requester for further data */
inname = rtfilerequest(,,'GEDCOM Input File',,'rt_pubscrname = '||PSCR||' rtfi_initialpath = RAM:',)
end
else do
Tell("Please enter the filename (with complete path) of the GEDCOM file:")
TellNN("Input file: ")
inname = readln(scrdev)
inname = strip(inname, 'b', ' "')
end
if inname = '' then
EndString("ERROR: No Input File!")
end
if ~open(infile, inname, "r") then
EndString("ERROR: Input file '"inname"' not found!")
if outp then do
if usereq then do
donotes = rtezrequest("Create external Note files for Scion for "||,
NL||'long GEDCOM comment lines?'||,
'',' _Yes| _No ','Input Request:','rt_pubscrname = '||pscr)
if donotes then do
prstot='Scion Database name: '||dbname||NL
if notesdir~="" then do
prstot=prstot||'Scion Notes directory: '||NL||'"'||notesdir||'"'||NL
prstot=prstot||'The Note files will be created using this name,'||NL
prstot=prstot||'and in this directory.'||NL
end
else
prstot=prstot||'The Note files will be created using this name.'||NL
prstot=prstot||'If that is not what you want, abort and save'||NL
prstot=prstot||'your (possibly empty) database first under a'||NL
prstot=prstot||'different name! '||NL||' Please make your choice: '
docont = rtezrequest(prstot,' _Continue | _Abort ','Converter Message:','rt_pubscrname = '||PSCR)
if docont = 0 then EXIT; /* EndString("Aborted!") */
if notesdir = "" then do
notesdir = rtfilerequest(,,'Select Notes Directory:','_Ok','rt_pubscrname = '||pscr||' rtfi_flags = freqf_nofiles rtfi_initialpath = RAM:',fres)
if fres = 0 then donotes = 0
/* User cancelled requester: no external note files will be created */
/* For future use:
if donotes then do
ntovw = rtezrequest('Overwrite existing note files?'||,
'',' _Yes | _No ','Converter Message:','rt_pubscrname = '||PSCR)
end
*/
end
end
end
else do
Tell("Create external Note files for Scion for long")
TellNN("GEDCOM comment lines (y/n)? ")
innote = readln(scrdev)
innote = upper(left(innote, 1))
if innote = "Y" then donotes = 1
else donotes = 0
Tell("")
if donotes then do
innote = ""
do until innote = "Y" | innote = "N"
Tell("Scion Database name: "||dbname)
if notesdir ~= "" then do
Tell("Scion Notes directory: "||NL||'"'||notesdir||'"')
Tell("The Note files will be created using this name,")
Tell("and in this directory.")
end
else
Tell("The Note files will be created using this name.")
Tell("If that is not what you want, abort and save your")
Tell("(possibly empty) database first under a different name!")
TellNN("Continue (y/n): ")
innote = readln(scrdev)
innote = upper(left(innote, 1))
end
if innote ~= "Y" then EndString("Aborted.")
if notesdir = "" then do
ptmp = ""
do until ptmp = ":" | ptmp = "/"
Tell("Enter full directory name where Scion's note files are located")
TellNN("(MUST end with ':' or '/'): ")
innote = readln(scrdev)
innote = strip(innote, 'b', ' "')
ptmp = right(innote, 1)
end
notesdir = innote
end
/* For future use:
TellNN("Overwrite existing Note files? (y/n): ")
innote = readln(scrdev)
innote = upper(left(innote, 1))
if innote = "Y" then ntovw = 1
else ntovw = 0
*/
end
end
end
ntovw = 1
if ~usereq then
Tell("Be patient - this may take a while...")
/* Initialize line count, individual counter and family counter */
ink = GetNextLine()
if left(ink, 6) ~= "0 HEAD" then do
close(infile)
EndString("ERROR: Invalid beginning of file - not a valid GEDCOM format")
end
lvlstr = '0'; lvl = 1; atlvl = 1
IRNArr.0 = ''; IRNArr.1 = ''; FGRNArr.0 = ''; FGRNArr.1 = ''
/* Read the "HEAD(ER)" section until we find something else of level "0" */
prstot = ""
ink = ParseHeader(atlvl)
prsr = "Destination: Scion Genealogist "||prgvers
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
prsr = "Dest. file: "||dbname
if ~usereq then
Tell(prsr||NL||"Scanning file for persons...")
else do
prstot=prstot||prsr||NL||NL||"Parsing will take a while - be patient."||,
NL||"Click `Continue' to start parsing..."
rv = rtezrequest(prstot,'_Continue| _Abort ','Converter Message:','rt_pubscrname = '||PSCR)
if rv = 0 then EXIT
end
/* TO DO: if inname ends on .GED, strip the extension */
if ~open(errfile, inname||".log", "w") then
errfile = stdout
/* Now scan the following level "0" fields for individuals;
* skip the families, for the moment
*/
irn = 0; famline = 0
if prgrs then do
Postmsg(10, 10, "GEDCOM to Scion (by Freddy Ariës)\Database: "||,
StripPath(inname)||"\Persons parsed: "||irn||"\ ", PSCR)
pgopen = 1
end
replay = 0
do while ~eof(infile)
lvlstr = word(ink, 1)
lvl = GetNumType(lvlstr)
if lvl = atlvl then do
tagstr = upper(word(ink, words(ink)))
if (tagstr="INDI" | tagstr="INDIVIDUAL") then do
nstr = compress(word(ink, 2), '@ ')
tp = GGetIRN(nstr)
if tp ~= 0 then
writeln(errfile, "ERROR: Duplicate person encountered: "||nstr||" (IRN "||tp||") (line: "||lnum||")")
irn = irn + 1
if pgopen then Postmsg(,, "\\Persons parsed: "||irn||"\ ", PSCR)
ink = ParsePerson(nstr, lvl)
if ink ~= "" then replay = 1
end
else if ((tagstr="FAM" | tagstr="FAMILY") & famline = 0) then
famline=lnum
end
/* Skip all lines with level ~= current level (0) */
if replay = 0 then ink = GetNextLine()
else replay = 0
end
if ~usereq then
Tell("Number of persons parsed: "||irn)
/* Now rescan the entire file for FAMilies; I know it is quite
* inefficient this way, but it's better to add all the persons first,
* and then establish the relations...
*/
replay = 0
fgrn = 0; fxs = 0
if ~usereq then
Tell("Scanning file again to establish relations...")
if pgopen then Postmsg(,, "\\\Families parsed: 0 (scanning...)", PSCR)
/* If we've already passed the first FAM line, go back to that line
* in the file. Otherwise, just continue where we are.
*/
if famline > 0 then do
famline = famline - 1
close(infile)
if ~open(infile, inname, 'r') then
EndString("ERROR: Unable to read relations!")
lvlstr = '0'; lvl = 1; atlvl = 1; lnum = 0
do while ~eof(infile) & lnum < famline
lnum = lnum + 1
ink = readln(infile)
end
end
do while ~eof(infile)
if replay = 0 then ink = GetNextLine()
else replay = 0
lvlstr = word(ink, 1)
lvl = GetNumType(lvlstr)
if lvl = atlvl then do
tagstr = upper(word(ink, words(ink)))
if (tagstr = "FAM" | tagstr = "FAMILY") then do
nstr = compress(word(ink, 2),'@ ')
fp = GGetFGRN(nstr)
if fp ~= 0 then
writeln(errfile, "WARNING: Duplicate family encountered: "||nstr||" (FGRN "||fp||") (line: "||lnum||")")
/* TO DO: is the error message necessary? Or can we simply go on? */
else
fgrn = fgrn + 1
if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, PSCR)
ink = ParseFamily(nstr, lvl)
if ink ~= "" then replay = 1
end
else if (tagstr = "TRLR" | tagstr = "TRAILER") then do
close(infile)
if pgopen then do
Postmsg()
pgopen = 0
end
if usereq then do
EndString("PARSING DONE:"||NL||"Number of persons parsed: "||irn||,
NL||"Number of families parsed: "||fgrn||,
NL||NL||"DON'T FORGET TO SAVE YOUR SCION FILE!!!")
end
else do
EndString("Number of families parsed: "||fgrn||NL||,
NL||"DONE! DON'T FORGET TO SAVE YOUR SCION FILE!!!")
end
end
end
/* Skip all the fields at lvl ~= this level */
end
close(infile)
if (ink ~= "0 TRLR") & (ink ~= "0 TRAILER") then
EndString("ERROR: Unexpected end of file")
else
EndString("ERROR: Trailer not recognized! (line: "||lnum||")")
ParseHeader: PROCEDURE EXPOSE infile prstot NL outp usereq scrdev lnum pgopen pscr
parse arg inilvl
do while ~eof(infile)
ins = GetNextLine()
if ins = "" then
EndString("ERROR: Unexpected end of file")
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= inilvl then RETURN ins
if lvl = inilvl+1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
if left(curr,4) = "SOUR" then do
lstr = strip(delstr(lstr, 1, length(curr)))
prsr = "Source system: "||lstr
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
ins = ParseSource(lvl)
lvlstr = word(ins, 1)
lvl = lvlstr + 1
if lvl <= inilvl then RETURN ins
if lvl = inilvl+1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = upper(word(lstr, 1))
end
else EndString("ERROR: This should never happen [1] (line: "||lnum||")")
end
if curr = "DATE" then do
lstr = strip(delstr(lstr, 1, length(curr)))
prsr = "Creation date: "||lstr
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
end
else if curr = "FILE" then do
lstr = strip(delstr(lstr, 1, length(curr)))
prsr = "Source file: "||lstr
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
end
/* add COPR (copyright) and GEDC VERS parsing
*/
end
end
EndString("ERROR: Unexpected end of file")
ParseSource: PROCEDURE EXPOSE infile prstot NL outp usereq scrdev lnum pgopen pscr
parse arg namlvl
/* Scan for "NAME" and "VERS" */
do while ~eof(infile)
ins = GetNextLine()
if ins = "" then
EndString("ERROR: Unexpected end of file")
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= namlvl then RETURN ins
if lvl = namlvl+1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = left(upper(word(lstr, 1)),4)
if curr = "VERS" then do
lstr = strip(delstr(lstr, 1, length(curr)))
prsr = "Version: "||lstr
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
end
else if curr = "NAME" then do
lstr = strip(delstr(lstr, 1, length(curr)))
prsr = "Created by: "||lstr
if ~usereq then
Tell(prsr)
else
prstot = prstot||prsr||NL
end
end
end
EndString("ERROR: Unexpected end of file")
ParsePerson: PROCEDURE EXPOSE infile IrnArr. errfile outp usereq scrdev lnum donotes dbname ntovw notesdir pgopen pscr prgvers
parse arg pnum, inilvl
replay = 0
prn = GetNewPerson()
IRNArr.0 = IRNArr.0||pnum||' '
IRNArr.1 = IRNArr.1||prn||' '
noteset = 0; refset = 0; oldnotestr = ""
do while ~eof(infile)
if replay = 0 then ins = GetNextLine()
else replay = 0
if ins = "" then
EndString("ERROR: Unexpected end of file")
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= inilvl then RETURN ins
if lvl = inilvl + 1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = upper(word(lstr, 1))
restcurr = delstr(lstr, 1, length(curr))
if curr="FAMILY_CHILD" then curr = "FAMC"
else if curr="FAMILY_SPOUSE" then curr = "FAMS"
else if curr = "REFERENCE" then curr = "REFN"
else if curr = "CHRISTENING" | curr = "ADULT_CHRISTENING" then curr = "CHR"
else if length(curr) > 4 then curr = left(curr, 4)
end
if curr = "NAME" then StorePersName(strip(restcurr), prn)
else if curr = "SEX" then StorePersSex(strip(restcurr), prn)
else if (curr="BIRT" | curr="DEAT" | curr="BURI" | curr="CHR" | curr="BAPM" | curr="BAPL" | curr="CHRA" | curr="CONF" | curr = "BAPT") then
do
if left(curr,3) = "BAP" then curr = "BAP"
else if left(curr,3) = "CHR" then curr = "CHR"
/* note that BAPT is not official GEDCOM standard, but is for
* compatibility with long-form tags BAPTISM and BAPTISM-LDS, which are
* treated the same anyway.
*/
ins = ParsePersDatePlace(curr, prn, lvl)
replay = 1
end
else if curr = "OCCU" then StoreOccup(strip(restcurr), prn)
else if curr = "EDUC" then StoreEduc(strip(restcurr), prn)
else if curr = "RELI" then StoreRelig(strip(restcurr), prn)
else if curr = "STIL" then StoreCOD("stillborn", prn)
/* Note: 'STIL' is not yet part of the official GEDCOM standard */
else if curr = "NOTE" then do
if lvl > inilvl + 1 then do
ntstr = strip(delstr(ins, 1, length(lvlstr)))
ntcurr = left(upper(word(ntstr, 1)),4)
notestr = delstr(ntstr, 1, length(ntcurr)+1)
end
else do
ntstr = lstr
ntcurr = curr
notestr = delstr(restcurr, 1, 1)
end
/* In both cases above, we only strip the first leading blank (which
* is the delimiter), and leave other leading blanks untouched.
*/
if noteset = 0 then do
StorePersComment(notestr, prn)
oldnotestr = notestr
noteset = 1
end
else if donotes & (ntcurr = "NOTE" | ntcurr = "CONT" | ntcurr = "CONC") then do
nfname = notesdir||"PN"||prn||"."||dbname
if noteset = 1 then do
if ~ntovw then do
DoAppend(nfname, oldnotestr)
DoAppend(nfname, notestr)
end
else if open(notefile, nfname, 'w') then do
writeln(notefile, oldnotestr)
writeln(notefile, notestr); /* append new string */
close(notefile)
end
StorePersComment("[see notes]", prn)
noteset = 2
end
else
DoAppend(nfname, notestr); /* noteset = 2 => always append */
if prgvers >= 5 then do
PUTPERSNOTE prn nfname
end
end
else
writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||ntcurr||" for person "||pnum||"! (line: "||lnum||")")
end
else if curr = "SOUR" then do
prline = strip(restcurr)
if ~refset then do
if prline ~= "" then do
prline = strip(prline,'b','@')
StorePersRefs(prline, prn)
refset = 1
end
end
else do
lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
ins = SkipField(lvl, lostr, pnum, 0, 0)
if ins ~= 0 then replay = 1
end
end
else if (curr="FAMC" | curr="FAMS" | curr="NUMB") then do
/* nothing - children and spouse relationships are established later
* and NUMB fields are considered to be irrelevant (are not even
* part of the official GEDCOM specification, btw)
* Note: we do not output a "Skipped" message for these fields.
*/
end
else if (curr = "CHAN" | curr = "REFN") then do
ins = SkipChanged(lvl)
replay = 1
/* no 'SKIPPED' message for these fields */
end
else do
ins = SkipField(lvl, curr, prn, 0, 0)
if ins ~= 0 then replay = 1
end
end
EndString("ERROR: Unexpected end of file")
ParseFamily: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum fline flcnt FFile. FGRNArr. IRNArr. donotes dbname ntovw notesdir pgopen pscr prgvers
parse arg fnum, inilvl
replay = 0; fxs = 0; fins = 0
finp = 0; flcnt = 0; fline = 0; FFile. = ""
noteset = 0; refset = 0; oldnotestr = ""
/* replay: parse the currently read line, don't read the next one
* fxs : family exists; if 0, only allow HUSB and WIFE, rest to temp-array
* ~= 0, then contains FGRN (family number)
* finp : file input; 0 = from sourcefile (GEDCOM), 1 = from temp-array
* fline : currently parsed line in temp-array / flcnt : max number of lines
* FFile : the temporary array used for this
*/
do while (finp = 0 & ~eof(infile)) | (finp = 1 & (fline <= flcnt))
if replay = 0 then ins = GetNextFLine(finp)
else
replay = 0
if ins = "" & finp = 0 then
EndString("ERROR: Unexpected end of file!")
if finp = 1 & (fline > flcnt) then RETURN fins
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if (lvl <= inilvl) & (finp = 0) then do
if flcnt = 0 then RETURN ins
finp = 1; fline = 0
fins = ins; /* backup the currently read line */
ITERATE
end
if lvl = inilvl + 1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = upper(word(lstr, 1))
restcurr = delstr(lstr, 1, length(curr))
prsid = compress(restcurr, ' @')
if curr = "DIVORCE" then curr = "DIV"
else if curr="ANNULMENT" then curr = "ANUL"
else if curr="REFERENCE" then curr = "REFN"
else if length(curr) > 4 then curr = left(curr, 4)
end
if curr="HUSB" then fxs = StoreFamHusband(prsid, fnum)
else if curr = "WIFE" then fxs = StoreFamWife(prsid, fnum)
else if curr="CHIL" then do
if lvl > inilvl + 1 then do
lostr = left(upper(word(strip(delstr(ins, 1, length(lvlstr))), 1)), 4)
if lostr = "ADOP" then
StoreChildAdopt(prsid)
else do
ins = SkipField(lvl, lostr, fnum, finp, 1)
if ins ~= 0 then replay = 1
end
ITERATE
end
if fxs = 0 then do
if finp = 1 then
writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
else
FOutput(ins)
end
else StoreFamChild(prsid, fxs)
end
else if (curr="MARR" | curr="DIV" | curr="ANUL" | curr="ENGA") then do
if fxs = 0 then do
if finp = 1 then
writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
else
FOutput(ins)
end
ins = ParseFamDatePlace(curr, fxs, lvl, upper(prsid), finp)
if ins ~= 0 then replay = 1
end
else if curr = "NOTE" then do
if lvl > inilvl + 1 then do
ntstr = strip(delstr(ins, 1, length(lvlstr)))
ntcurr = left(upper(word(ntstr, 1)),4)
notestr = strip(delstr(ntstr, 1, length(ntcurr)))
end
else do
ntstr = lstr
ntcurr = curr
notestr = strip(restcurr)
end
if noteset = 0 then do
if fxs ~= 0 then do
StoreFamComment(notestr, fxs)
oldnotestr = notestr
noteset = 1
end
else do
if finp = 1 then
writeln(errfile, "ERROR: Family does not exist for "||ntstr||" !")
else
FOutput(ins)
end
end
else if donotes & (ntcurr = "NOTE" | ntcurr = "CONT" | ntcurr = "CONC") then do
/* only called if noteset = 1, thus fxs ~= 0 */
if fxs ~= 0 then do
nfname = notesdir||"FN"||fxs||"."||dbname
if noteset = 1 then do
if ~ntovw then do
DoAppend(nfname, oldnotestr)
DoAppend(nfname, notestr)
end
else if open(notefile, nfname, 'w') then do
writeln(notefile, oldnotestr)
writeln(notefile, notestr); /* append new string */
close(notefile)
end
StoreFamComment("[see notes]", fxs)
noteset = 2
end
else
DoAppend(nfname, notestr); /* noteset = 2 => always append */
if prgvers >= 5 then do
PUTFAMNOTE fxs nfname
end
end
else
writeln(errfile, "ERROR: Family for "||ntstr||" doesn't exist!")
end
else
writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||ntcurr||" for family "||fnum||"! (line: "||lnum||")")
end
else if curr = "SOUR" then do
frline = strip(restcurr)
if ~refset then do
if frline ~= "" then do
frline = strip(frline,'b','@')
if fxs ~= 0 then do
PUTFAMREFS fxs frline
refset = 1
end
else do
if finp = 1 then
writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
else
FOutput(ins)
end
end
end
else do
lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
ins = SkipField(lvl, lostr, fnum, finp, 1)
if ins ~= 0 then replay = 1
end
end
else if curr = "NUMB" | curr = "REFN" then do
/* No SKIPPED message for these fields, as they are irrelevant.
* NUMB fields are not even part of the official GEDCOM specification.
* It's just here because eg. ROOTS uses them a lot, and I don't want
* the program to output a "SKIPPED" line for them in the log file.
*/
end
else if curr = "CHAN" then do
ins = SkipChanged(lvl)
replay = 1
/* no 'SKIPPED' message for these fields */
end
else do
ins = SkipField(lvl, curr, fnum, finp, 1)
if ins ~= 0 then replay = 1
end
end
if finp = 1 then RETURN fins
EndString("ERROR: Unexpected end of file!")
GetNumType: PROCEDURE EXPOSE outp infile usereq lnum pgopen pscr scrdev
parse arg str
if ~DATATYPE(str, 'w') then
EndString("ERROR: Level indicator expected -> error in GEDCOM specification?"||'0A'x||"String is "||str||" (line: "||lnum||")")
return str + 1
GetNextFLine: PROCEDURE EXPOSE infile fline flcnt lnum FFile.
parse arg finp
if finp = 0 then return GetNextLine()
ignl = ""
do while ignl = "" & fline <= flcnt
fline = fline + 1
ignl = FFile.fline
if ignl ~= "" then ignl = strip(ignl, 'B', ' ')
/* strip leading and trailing spaces, tabs and ^M (linefeed) characters */
/* also skip empty lines */
end
return ignl
GetNextLine: PROCEDURE EXPOSE infile lnum
lnum = lnum + 1
ignl = ""
do while ignl = "" & ~eof(infile)
ignl = readln(infile)
if ignl ~= "" then ignl = strip(ignl, 'B', ' ')
/* strip leading and trailing spaces, tabs and ^M (linefeed) characters */
/* also skip empty lines */
end
return ignl
FOutput: PROCEDURE EXPOSE flcnt FFile.
parse arg iline
FFile.flcnt = iline
flcnt = flcnt + 1
return 0
StorePersName: PROCEDURE
parse arg nstr, pnum
nstr = strip(nstr, 'B', '/')
ps = pos('/', nstr)
if ps = 0 then do
fname = ""
lname = nstr
end
else do
fname = left(nstr, ps-1)
lname = compress(right(nstr, length(nstr)-ps),'/')
end
PUTLASTNAME pnum lname
PUTFIRSTNAME pnum fname
return 1
StorePersSex: PROCEDURE
parse arg nstr, pnum
sxstr = upper(left(nstr, 1))
if sxstr ~= 'M' then sxstr = 'F'
PUTSEX pnum sxstr
return 1
ParsePersDatePlace: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum pgopen pscr
parse arg idstr, pnum, inilvl
datstr = ""
plcstr = ""
causestr = ""
do while ~eof(infile)
ins = GetNextLine()
if eof(infile) then
EndString("ERROR: Unexpected end of file!")
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= inilvl then do
select
when idstr = "BIRT" then do
if datstr ~= "" then do
PUTBIRTHDATE pnum datstr
if RESULT = 0 then
writeln(errfile, "Error in birth date '"||datstr||" for person "||pnum)
end
if plcstr ~= "" then
PUTBIRTHPLACE pnum plcstr
end
when idstr = "DEAT" then do
if datstr ~= "" then do
PUTDEATHDATE pnum datstr
if RESULT = 0 then
writeln(errfile, "Error in death date '"||datstr||" for person "||pnum)
end
if plcstr ~= "" then
PUTDEATHPLACE pnum plcstr
if causestr ~= "" then
PUTDIEDOF pnum causestr
end
when idstr = "BURI" then do
if datstr ~= "" then do
PUTBURIALDATE pnum datstr
if RESULT = 0 then
writeln(errfile, "Error in burial date '"||datstr||" for person "||pnum)
end
if plcstr ~= "" then
PUTBURIALPLACE pnum plcstr
end
when (idstr="BAP" | idstr="CHR" | idstr="CONF") then do
if datstr ~= "" then do
PUTBAPTISMDATE pnum datstr
if RESULT = 0 then
writeln(errfile, "Error in baptism date '"||datstr||" for person "||pnum)
end
if plcstr ~= "" then
PUTBAPTISMPLACE pnum plcstr
end
otherwise
/* do nothing */
end
RETURN ins
end
else if lvl = inilvl+1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = upper(word(lstr, 1))
if curr = "DATE" then do
datstr = ParseDate(strip(delstr(lstr, 1, length(curr))))
/* TO DO: add some more parsing of the date string
* - dates ending on /x (indicating a choice of years)
* - "BET" dates (between 2 dates)
* etc.
*/
end
else if (curr="PLAC" | curr="PLACE") then do
plcstr = strip(delstr(lstr, 1, length(curr)))
end
else if (curr="QUAY" | curr="QUALITY_OF_DATA") then do
/* only add '?' for QUAY 0 fields */
lstr = strip(delstr(lstr, 1, length(curr)))
if DATATYPE(lstr, 'w') & lstr < 1 then do
if datstr ~= "" then datstr = datstr||'?'
if plcstr ~= "" then plcstr = plcstr||'?'
end
end
else if (curr="CAUS" | curr="CAUSE") then do
causestr = strip(delstr(lstr, 1, length(curr)))
end
end
else do
/* lvl > inilvl+1 */
qlstr = strip(delstr(ins, 1, length(lvlstr)))
qcurr = upper(word(qlstr, 1))
if (qcurr="QUAY" | qcurr="QUALITY_OF_DATA") then do
/* only add '?' for QUAY 0 fields */
qlstr = strip(delstr(qlstr, 1, length(qcurr)))
if DATATYPE(qlstr, 'w') & qlstr < 1 then do
if curr = "DATE" & datstr ~= "" then
datstr = ParseDate(datstr)||'?'
if (curr = "PLAC" | curr = "PLACE") & plcstr ~= "" then
plcstr = plcstr||'?'
end
end
else do
/* else: skip all other fields of level inilvl+1 */
writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||qcurr||" for person "||pnum||"! (line: "||lnum||")")
end
end
end
return 0
ParseFamDatePlace: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum fline flcnt pgopen pscr FFile. FGRNArr.
parse arg idstr, ff, inilvl, idr, finp
datstr = ""; plcstr = ""; clbrnt = ""; wtness = ""
if idstr="ANUL" then divtype = 4
else if (idr = "N" & idstr="DIV") then divtype = 1
else divtype = 2
/* some programs (like PAF 2.2) have "DIV Y" and "DIV N" fields
* DIV Y (yes) is treated identical to "DIV" (without arguments)
* DIV N (no) is treated as 'Ending: None'
*/
do while ~eof(infile) | (fline < flcnt)
ins = GetNextFLine(finp)
if finp = 0 & ins = "" then
EndString("ERROR: Unexpected end of file (Parsing Family Events)!")
if finp = 1 & (fline > flcnt) then do
if ff ~= 0 then do
if idstr="MARR" then do
if datstr ~= "" then do
PUTMARRYDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in marriage date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTMARRYPLACE ff plcstr
if clbrnt ~= "" then
PUTCELEBRANT ff clbrnt
if wtness ~= "" then
PUTWITNESS ff wtness
end
else if (idstr="ANUL" | idstr="DIV") then do
if datstr ~= "" then do
PUTENDDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in ending date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTENDPLACE ff plcstr
PUTENDING ff divtype
end
else if idstr="ENGA" then do
if datstr ~= "" then do
PUTENGAGEDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in engagement date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTENGAGEPLACE ff plcstr
end
end
RETURN 0
end
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= inilvl then do
if ff ~= 0 then do
if idstr="MARR" then do
if datstr ~= "" then do
PUTMARRYDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in marriage date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTMARRYPLACE ff plcstr
if clbrnt ~= "" then
PUTCELEBRANT ff clbrnt
if wtness ~= "" then
PUTWITNESS ff wtness
end
else if (idstr="DIV" | idstr="ANUL") then do
if datstr ~= "" then do
PUTENDDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in ending date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTENDPLACE ff plcstr
PUTENDING ff divtype
end
else if idstr="ENGA" then do
if datstr ~= "" then do
PUTENGAGEDATE ff datstr
if RESULT = 0 then
writeln(errfile, "Error in engagement date '"||datstr||" for family "||ff)
end
if plcstr ~= "" then
PUTENGAGEPLACE ff plcstr
end
end
RETURN ins
end
if finp = 0 & ff = 0 then FOutput(ins)
else do
if lvl = inilvl+1 then do
lstr = strip(delstr(ins, 1, length(lvlstr)))
curr = upper(word(lstr, 1))
if curr="QUALITY_OF_DATA" then curr = "QUAY"
else if length(curr) > 4 then curr = left(curr, 4)
if curr = "DATE" then do
datstr = ParseDate(strip(delstr(lstr, 1, length(curr))))
/* TO DO: add some more parsing of the date string */
end
else if curr="PLAC" then do
plcstr = strip(delstr(lstr, 1, length(curr)))
end
else if curr="OFFI" then do
clbrnt = strip(delstr(lstr, 1, length(curr)))
/* only for "MARR" */
end
else if curr="WITN" then do
wtness = strip(delstr(lstr, 1, length(curr)))
/* only for "MARR" */
end
else if curr="QUAY" then do
/* only add '?' for QUAY 0 fields */
lstr = strip(delstr(lstr, 1, length(curr)))
if DATATYPE(lstr, 'w') & lstr < 1 then do
if datstr ~= "" then datstr = ParseDate(datstr)||'?'
if plcstr ~= "" then plcstr = plcstr||'?'
end
end
else if (curr = "TYPE" & idstr = "DIV") then do
lstr = upper(strip(delstr(lstr, 1, length(curr))))
if left(lstr, 3) = "SEP" then divtype = 3
else if left(lstr, 4) = "DEAT" then divtype = 5
else divtype = 2
/* default is 'DIVORCE' */
end
end
else if lvl > inilvl + 1 then do
qlstr = strip(delstr(ins, 1, length(lvlstr)))
qcurr = upper(word(qlstr, 1))
if (qcurr="QUAY" | qcurr="QUALITY_OF_DATA") then do
/* only add '?' for QUAY 0 fields */
qlstr = strip(delstr(qlstr, 1, length(qcurr)))
if DATATYPE(qlstr, 'w') & qlstr < 1 then do
if curr = "DATE" & datstr ~= "" then
datstr = ParseDate(datstr)||'?'
if curr = "PLAC" & plcstr ~= "" then
plcstr = plcstr||'?'
end
end
else do
/* else: skip all other fields of level inilvl+1 */
writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||qcurr||" for family "||ff||"! (line: "||lnum||")")
end
end
end
end
EndString("ERROR: Unexpected end of file (Parsed Family Events)!")
GetNewPerson: PROCEDURE EXPOSE infile outp usereq scrdev pgopen pscr
PUTNEWPERSON
newpnum = RESULT
if newpnum = 0 then EndString("ERROR: Cannot allocate new person!")
/* if you want to see Scion in action, uncomment the next line */
/* GETPERSONWIN newpnum */
return newpnum
GetNewFamily: PROCEDURE EXPOSE infile outp usereq scrdev pgopen pscr
parse arg irn
PUTNEWFAMILY irn
newfnum = RESULT
if newfnum = 0 then EndString("ERROR: Cannot allocate new family!")
/* if you want to see Scion in action, uncomment the next line */
/* GETFAMILYWIN newfnum */
return newfnum
StoreOccup: PROCEDURE
parse arg nstr, pnum
PUTOCCUPATION pnum nstr
return 1
StoreEduc: PROCEDURE
parse arg nstr, pnum
PUTEDUCATION pnum nstr
return 1
StoreRelig: PROCEDURE
parse arg nstr, pnum
PUTRELIGION pnum nstr
return 1
StoreCOD: PROCEDURE
parse arg nstr, pnum
PUTDIEDOF pnum nstr
return 1
StorePersComment: PROCEDURE
parse arg nstr, pnum
if pnum ~= 0 then
PUTPERSCOMMENT pnum nstr
return 1
StorePersRefs: PROCEDURE
parse arg nstr, pnum
if pnum ~= 0 then
PUTPERSREFS pnum nstr
return 1
StoreFamHusband: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
nstr = compress(nstr,'@ ')
ff = 0
ii = GGetIRN(nstr)
if ii = 0 then
writeln(errfile, "ERROR: Missing Personal Record for HUSBAND "||nstr||" (line: "||lnum||")")
else do
ff = GGetFGRN(fnum)
if ff = 0 then do
ff = GetNewFamily(ii)
FGRNArr.0 = FGRNArr.0||fnum||' '
FGRNArr.1 = FGRNArr.1||ff||' '
end
else do
/* There already is a family, so there is a principal; assume
* that that is the wife - add the husband as spouse
*/
PUTSPOUSE ff ii
ers = RESULT
if ers ~= 1 then do
writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (HUSB) "||ff||' '||ii)
GETPRINCIPAL ff
prc = RESULT
GETSPOUSE ff
spc = RESULT
writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
end
end
end
return ff
StoreFamWife: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
nstr = compress(nstr,'@ ')
ff = 0
ii = GGetIRN(nstr)
if ii = 0 then
writeln(errfile, "ERROR: Missing Personal Record for WIFE "||nstr||" (line: "||lnum||")")
else do
ff = GGetFGRN(fnum)
if ff = 0 then do
ff = GetNewFamily(ii)
FGRNArr.0 = FGRNArr.0||fnum||' '
FGRNArr.1 = FGRNArr.1||ff||' '
end
else do
PUTSPOUSE ff ii
ers = RESULT
if ers ~= 1 then do
writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (WIFE) "||ff||' '||ii)
GETPRINCIPAL ff
prc = RESULT
GETSPOUSE ff
spc = RESULT
writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
end
end
end
return ff
StoreFamChild: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
/* TO DO: improve this function, to allow definition of children here,
* instead of in a separate personal record. Also look for "ADOP"
* field (adopted children)
*/
if fnum = 0 then RETURN 0
/* we cannot parse a child when there is no family yet */
nstr = compress(nstr,'@ ')
ii = GGetIRN(nstr)
if ii = 0 then
writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
else do
PUTCHILD fnum ii
ers = RESULT
if ers ~= 1 then
writeln(errfile, "ERROR "||ers||" in PUTCHILD "||fnum||' '||ii||" (line: "||lnum||")")
end
return 1
StoreChildAdopt: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr.
parse arg nstr
/* This uses an as yet undocumented (and maybe even unsupported) feature
* in Scion v4.07 and above. So don't be surprised if you see italicized
* names in the Family Details window (try alt-clicking on a child to
* toggle this)
*/
nstr = compress(nstr,'@ ')
ii = GGetIRN(nstr)
if ii = 0 then
writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
else
PUTADOPTION ii 1
return 1
StoreFamComment: PROCEDURE
parse arg nstr, ff
PUTFAMCOMMENT ff nstr
return 1
/* Return the Scion IRN belonging to the GEDCOM Personal number pnum */
GGetIRN: PROCEDURE EXPOSE IRNArr.
parse arg pnum
anum = find(IRNArr.0, pnum)
if anum > 0 then
return word(IRNArr.1, anum)
else
return 0
/* Return the Scion FGRN belonging to the GEDCOM Family number fnum */
GGetFGRN: PROCEDURE EXPOSE lnum FGRNArr.
parse arg fnum
anum = find(FGRNArr.0, fnum)
if anum > 0 then
return word(FGRNArr.1, anum)
else
return 0
DoAppend: PROCEDURE
parse arg fname, ostr
if exists(fname) then
rval = open(notefile, fname, 'a')
else
rval = open(notefile, fname, 'w')
if rval then do
writeln(notefile, ostr)
close(notefile)
end
return 0
SkipChanged: PROCEDURE EXPOSE infile lnum
parse arg inlvl
lvl = inlvl + 1
do until lvl <= inlvl
ins = GetNextLine()
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
end
return ins
SkipField: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum fline flcnt pgopen pscr FFile.
arg inilvl, lostr, xnum, finp, pflag
if pflag = 0 then
writeln(errfile, "SKIPPED: Level "||inilvl||" field "||lostr||" for person "||xnum||"! (line: "||lnum||")")
else
writeln(errfile, "SKIPPED: Level "||inilvl||" field "||lostr||" for family "||xnum||"! (line: "||lnum||")")
do while ~eof(infile) | (pflag = 1 & fline < flcnt)
ins = GetNextFLine(finp)
if finp = 0 & ins = "" then
EndString("ERROR: Unexpected end of file (while skipping fields)!")
lvlstr = word(ins, 1)
lvl = GetNumType(lvlstr)
if lvl <= inilvl then RETURN ins
writeln(errfile, "SKIPPING: Level "||lvl||"("||inilvl||") line: '"||ins||"'")
end
EndString("ERROR: Unexpected end of file (while skipping fields)!")
/*
* Procedure to strip the directory path from the string,
* only leaving the filename
*/
StripPath: PROCEDURE
parse arg str
p = lastpos('/', str)
if p > 0 then ret1 = delstr(str,1,p)
else ret1 = str
p = lastpos(':', ret1)
if p > 0 then retstr = delstr(ret1,1,p)
else retstr = ret1
return retstr
/*
* Procedure to strip the date string so that it has the correct
* format (for Scion v5 and higher)
*/
ParseDate: PROCEDURE EXPOSE prgvers
parse arg datestr
if prgvers < 5 | left(datestr, 3) = '%%%' then return datestr
retstr = ""; prefstr = ""; leftstr = ""
datestr = upper(strip(datestr, 'b'))
if right(datestr, 4) = 'B.C.' then do
retstr = retstr||'BC'
datestr = strip(left(datestr, length(datestr)-4), 't')
end
else if right(datestr, 2) = 'BC' then do
retstr = retstr||' BC'
datestr = strip(left(datestr, length(datestr)-2), 't')
end
yearstr=""
wordcnt = words(datestr)
if wordcnt > 0 then do
/* get year */
yearstr = word(datestr, wordcnt)
datestr = left(datestr, length(datestr)-length(yearstr))
startix = verify(yearstr, "0123456789", 'm')
if startix > 1 then do
datestr = datestr||left(yearstr, startix - 1)
yearstr = right(yearstr, length(yearstr) - startix + 1)
end
else if startix = 0 then do
yearstr = "0000"
end
endix = verify(yearstr, "0123456789")
if endix > 0 then do
yearstr = left(yearstr, endix - 1)
end
if length(yearstr) > 4 then do
yearstr = left(yearstr, 4)
end
datestr = strip(datestr, 't')
end
retstr = right("0000"||yearstr, 4)||retstr
wordcnt = words(datestr)
if wordcnt > 0 then do
w1str = word(datestr, 1)
modstr = left(w1str, 3)
modix = find("ABT ABO EST AFT BEF PRE", modstr)
if modix > 0 then do
datestr = strip(right(datestr, length(datestr)-length(w1str)), 'L', ' -')
prefstr = word("~ ~ ~ > < <", modix)
end
else if modstr = "BET" then do
datestr = strip(right(datestr, length(datestr)-length(w1str)), 'L')
prefstr = '<'
rightix = index(datestr, " AND")
if rightix > 0 then do
leftstr = ParseDate(left(datestr, rightix))
/* what to do with this first date? */
datestr = strip(right(datestr, length(datestr) - rightix + 1), 'b')
end
end
end
/* scan for month */
monthix = 0
wordcnt = words(datestr)
if wordcnt > 0 then do
monthstr = word(datestr, wordcnt)
monthix = find("JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC", monthstr)
datestr = strip(left(datestr, length(datestr)-length(monthstr)), 'T')
end
retstr = right("00"||monthix, 2)||"-"||retstr
/* scan for day */
wordcnt = wordcnt - 1
daystr = ""
if wordcnt > 0 then do
daystr = word(datestr, wordcnt)
datestr = strip(left(datestr, length(datestr)-length(daystr)), 't')
startix = verify(daystr, "0123456789", 'm')
if startix > 1 then do
daystr = right(daystr, length(daystr) - startix + 1)
end
else if startix = 0 then do
daystr = "00"
end
endix = verify(daystr, "0123456789")
if endix > 0 then do
daystr = left(daystr, endix - 1)
end
if length(daystr) > 2 then do
daystr = left(daystr, 2)
end
end
retstr = right("00"||daystr, 2)||"-"||retstr
prefstr = "%%%"||prefstr
return prefstr||retstr
Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writeln(scrdev, str)
return 0
TellNN: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writech(scrdev, str)
return 0
EndString: PROCEDURE EXPOSE usereq outp pgopen pscr scrdev infile
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = '||PSCR)
else
Tell(str || '0A'x)
if outp & ~usereq & (scrdev ~= stdout) then do
Tell("Press <return> to exit.")
readln(scrdev)
close(scrdev)
end
close(infile)
EXIT
/* Let's make sure you get a nice message when you turn off the printer :-) */
IOERR:
bline = SIGL
say "I/O error #"||RC||" detected in line "||bline||":"
say sourceline(bline)
if pgopen then Postmsg()
EXIT
